home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / collectfn.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-04-19  |  11.9 KB  |  394 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;                                                                    ;;;;;
  3. ;;;     Copyright (c) 1989 by William Schelter,University of Texas     ;;;;;
  4. ;;;     All rights reserved                                            ;;;;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ;; See the doc/DOC file for information on emit-fn and
  8. ;; make-all-proclaims.  The basic idea is to utilize information gathered
  9. ;; by the compiler in a compile of a system of files in order to generate
  10. ;; better code on subsequent compiles of the system.  To do this a file
  11. ;; sys-proclaim.lisp should be produced.
  12.  
  13. ;; Additionally cross reference information about functions in the system is
  14. ;; collected.
  15.  
  16. (in-package 'compiler)
  17. (import 'sloop::sloop)
  18.  
  19. (defstruct fn
  20.   name           ;; name of THIS FUNCTION
  21.   def            ;; defun, defmacro 
  22.   value-type     ;; If this function's body contained
  23.                  ;; (cond ((> a 3) 7)
  24.          ;;      ((> a 1) (foo)))
  25.                  ;; then the return type of 7 is known at compile time
  26.                  ;; and value-type would be fixnum. [see return-type]
  27.   fun-values     ;; list of functions whose values are the values of THIS FN
  28.                  ;; (foo) in the previous example.
  29.   callees        ;; list of all functions called by THIS FUNCTION
  30.   return-type    ;; Store a return-type computed from the fun-values
  31.                  ;; and value-type field.  This computation is done later.
  32.   arg-types      ;; non optional arg types.  
  33.   no-emit        ;; if not nil don't emit declaration.
  34.   macros
  35.   )
  36.  
  37. (defvar *other-form* (make-fn))
  38. (defvar *all-fns* nil)
  39. (defvar *call-table* (make-hash-table))
  40. (defvar *current-fn* nil)
  41. (defun add-callee (fname)
  42.   (cond ((consp fname)
  43.      (or (eq (car fname) 'values)
  44.          (add-callee (car fname))))
  45.     ((eq fname 'single-value))
  46.     (fname (pushnew fname (fn-callees (current-fn))))))
  47.  
  48. (defun add-macro-callee (fname)
  49.   (or
  50.     ;; make sure the macro fname is not shadowed in the current environment.
  51.     (sloop::sloop for v in *funs*
  52.           when (and (consp v) (eq (car v) fname))
  53.           do (return t))
  54.     (pushnew fname (fn-macros (current-fn)))))
  55.  
  56. (defun clear-call-table ()
  57.   (setf *current-fn* nil)
  58.   (setq *all-fns* nil)
  59.   (setq *other-form* (make-fn :name 'other-form))
  60.   (clrhash *call-table*)
  61.   (setf (gethash 'other-form *call-table*) *other-form*) 
  62.   )
  63.  
  64. (defun emit-fn (flag) (setq *record-call-info* flag))
  65.  
  66. (defun type-or (a b)
  67.   (if (eq b '*) '*
  68.     (case a
  69.       ((nil) b)
  70.       ((t inline) t)
  71.       ((fixnum inline-fixnum fixnum-value) (if (eq b 'fixnum) 'fixnum
  72.                          (type-or t b)))
  73.       (otherwise '*)
  74.       )))
  75.  
  76. (defun current-fn ()
  77.   (cond ((and (consp *current-form*)
  78.           (member (car *current-form*) '(defun defmacro))
  79.           (symbolp  (second *current-form*))
  80.           (symbol-package (second *current-form*));;don't record gensym'd
  81.           )
  82.      (cond ((and *current-fn*
  83.              (equal (second *current-form*)  (fn-name *current-fn*)))
  84.         *current-fn*)
  85.            (t
  86.          (unless
  87.            (setq *current-fn*
  88.              (gethash (second *current-form*) *call-table*))
  89.            (setq *current-fn* (make-fn :name (second *current-form*)
  90.                            :def (car *current-form*)))
  91.            (setf (gethash (second *current-form*) *call-table*)
  92.              *current-fn*)
  93.            (setq *all-fns* (cons *current-fn* *all-fns*)))
  94.          *current-fn*)))
  95.     ;; catch all for other top level forms
  96.     (t *other-form*)))
  97.  
  98. (defun who-calls (f)
  99.   (sloop for (ke val) in-table *call-table*
  100.      when (or (member f (fn-callees val))
  101.           (member f (fn-macros val)))
  102.      collect ke))
  103.  
  104.  
  105. (defun add-value-type (x fn &aux (current-fn (current-fn)))
  106.   (cond (fn (pushnew fn
  107.              (fn-fun-values current-fn) :test 'equal))
  108.     (t
  109.       (setf (fn-value-type current-fn)
  110.         (type-or (fn-value-type current-fn) x)))))
  111.  
  112.  
  113. (defun get-var-types (lis)
  114.   (sloop::sloop for v in lis collect (var-type v)))
  115.  
  116. (defun record-arg-info( lambda-list &aux (cf (current-fn)))
  117.   (setf (fn-arg-types cf) (get-var-types (car lambda-list)))
  118.   (when (sloop::sloop for v in (cdr lambda-list)
  119.               for w in '(&optional &rest &key
  120.                        nil &allow-other-keys
  121.                        )
  122.               when (and v w) do (return '*))
  123.     (setf (fn-arg-types cf) (nconc(fn-arg-types cf) (list '*)))
  124.     ))
  125.  
  126. (defvar *depth* 0)
  127. (defvar *called-from* nil)
  128.  
  129. (defun get-value-type (fname)
  130.   (cond ((member fname *called-from* :test 'eq) nil)
  131.     (t
  132.      (let ((tem (cons fname *called-from*)))
  133.        (declare (:dynamic-extent tem))
  134.        (let ((*called-from* tem))
  135.          (get-value-type1 fname))))))
  136.  
  137. (defun get-value-type1 (fname
  138.             &aux tem (*depth* (the fixnum (+ 1 (the fixnum
  139.                                 *depth* )))))
  140.   (cond ((> (the fixnum *depth*) 100) '*)
  141.     ((setq tem (gethash fname *call-table*))
  142.      (or
  143.       (fn-return-type tem)
  144.       (sloop::sloop with typ = (fn-value-type tem)
  145.         for v in (fn-fun-values tem)
  146.         when (symbolp v)
  147.         do (setq typ (type-or typ (get-value-type v)))
  148.         else
  149.         when (and (consp v) (eq (car v) 'values))
  150.         do
  151.         (setq typ (type-or typ (if (eql (cdr v) 1) t '*)))
  152.         else do (error "unknown fun value ~a" v)
  153.         finally
  154.         ;; if there is no visible return, then we can assume
  155.         ;; one value.
  156.         (or typ (fn-value-type tem)
  157.             (fn-fun-values tem)
  158.             (setf typ t))
  159.         (setf (fn-return-type tem) typ)
  160.         (return typ)
  161.         )))
  162.     ((get fname 'return-type))
  163.     ((get fname 'proclaimed-return-type))
  164.     (t '*)))
  165.     
  166. (defun result-type-from-loc (x)
  167.   (cond ((consp x)
  168.      (case (car x)
  169.        ((fixnum-value inline-fixnum) 'fixnum)
  170.        (var (var-type (second x)))
  171.        ;; eventually separate out other inlines
  172.        (t (cond ((and (symbolp (car x))
  173.               (get (car x) 'wt-loc))
  174.              t)
  175.             (t (print (list 'type '* x)) '*)))))
  176.     ((or (eq x t) (null x)) t)
  177.     (t (print (list 'type '*2 x)) '*)))
  178.  
  179.  
  180. (defun small-all-t-p (args ret)
  181.   (and (eq ret t)
  182.        (< (length args) 10)
  183.        (sloop::sloop for v in args always (eq v t))))
  184.  
  185. ;; Don't change return type but pretend all these are optional args.
  186.  
  187. (defun no-make-proclaims-hack ()
  188.   (sloop::sloop for (ke val) in-table *call-table*
  189.      do (progn ke) (setf (fn-no-emit val) 1)))
  190.  
  191.   
  192. (defun make-proclaims ( &optional (st *standard-output*)
  193.                   &aux (ht (make-hash-table :test 'equal))
  194.                   *print-length* *print-level* 
  195.                   )
  196. ;  (require "VLFUN"
  197. ;     (concatenate 'string si::*system-directory*
  198. ;              "../cmpnew/lfun_list.lsp"))
  199.   
  200.   (print `(in-package ,(package-name *package*)) st)
  201.   (sloop::sloop with ret with at
  202.         for (ke val) in-table *call-table* 
  203.         do
  204.         (cond ((or (eql 1 (fn-no-emit val))
  205.                (not (eq (fn-def val) 'defun))))
  206.               (t (setq ret (get-value-type ke))
  207.              (setq at (fn-arg-types val))
  208.              (push ke   (gethash (list at ret)  ht)))))
  209.   (sloop::sloop for (at fns) in-table ht
  210.         do 
  211.         (print
  212.          `(proclaim '(ftype (function ,@ at) ,@ fns))
  213.          st)))
  214.          
  215. (defun setup-sys-proclaims()
  216.   (or (gethash 'si::call-test *call-table*)
  217.       (get 'si::call-test 'proclaimed-function)
  218.       (load (concatenate 'string si::*system-directory*
  219.              "../lsp/sys-proclaim.lisp"))
  220.       (no-make-proclaims-hack)
  221.       ))
  222.  
  223. (defun make-all-proclaims (&rest files)
  224.   (setup-sys-proclaims)
  225.   (dolist (v files)
  226.       (mapcar 'load (directory v)))
  227.   (write-sys-proclaims))
  228.  
  229. (defun write-sys-proclaims ()
  230.   (with-open-file (st "sys-proclaim.lisp" :direction :output)
  231.     (make-proclaims st)))
  232.  
  233. (defvar *file-table* (make-hash-table :test 'eq)) 
  234.  
  235. (defun add-fn-data (lis &aux tem file)
  236.   (let ((file (and (setq file (si::fp-input-stream *standard-input*))
  237.            (truename file))))
  238.   (dolist (v lis)
  239.       (cond ((eql (fn-name v) 'other-form)
  240.          (setf (fn-name v) (intern
  241.                     (concatenate 'string "OTHER-FORM-"
  242.                          (namestring file))))
  243.          (setf (get (fn-name v) 'other-form) t)))
  244.       (setf (gethash (fn-name v) *call-table*) v)
  245.       (if (setq tem (gethash (fn-name v) *file-table*))
  246.           (or (equal tem file)
  247.           (format t "~% Warn ~a redefined in ~a. Originally in ~a."
  248.               (fn-name v) file tem)))
  249.       (setf (gethash (fn-name v) *file-table*)
  250.         file))))
  251.  
  252. (defun dump-fn-data (&optional (file "fn-data.lsp")
  253.                    &aux (*package* (find-package "COMPILER"))
  254.                    (*print-length* nil)
  255.                    (*print-level* nil)
  256.                    )
  257.   (with-open-file (st file :direction :output)
  258.     (format st "(in-package 'compiler)(init-fn)~%(~s '(" 'add-fn-data)
  259.     (sloop::sloop for (ke val) in-table *call-table*
  260.           do (progn ke) (print val st))
  261.     (princ "))" st)
  262.     (truename st)))
  263.  
  264. (defun record-call-info (loc fname)
  265.   (cond ((and fname (symbolp fname))
  266.      (add-callee fname)))
  267.   (cond ((eq loc 'record-call-info) (return-from record-call-info nil)))
  268.   (case *value-to-go*
  269.     (return
  270.       (if (eq loc 'fun-val)
  271.       (add-value-type nil (or fname  'unknown-values))
  272.     (add-value-type (result-type-from-loc loc) nil)))
  273.     (return-fixnum
  274.       (add-value-type 'fixnum nil))
  275.     (return-object
  276.       (add-value-type t nil))
  277.     
  278.     (top  (setq *top-data* (cons fname nil))
  279.      ))
  280.      )
  281.  
  282. (defun list-undefined-functions (&aux undefs)
  283.   (sloop::sloop for (name fn) in-table *call-table*
  284.         declare (ignore name)
  285.         do (sloop for w in (fn-callees fn)
  286.               when (not (or (fboundp w)
  287.                     (gethash w *call-table*)
  288.                     (get w 'inline-always)
  289.                     (get w 'inline-unsafe)
  290.                     (get w 'other-form)
  291.                     ))
  292.               do (pushnew w undefs)))
  293.   undefs)        
  294.  
  295.  
  296.  
  297. (dolist (v '(throw coerce single-value  sort delete remove char-upcase
  298.            si::fset typep))
  299.     (si::putprop v t 'return-type))
  300.  
  301. (defun init-fn () nil)
  302.  
  303. (defun list-uncalled-functions ( )
  304.   (let* ((size (sloop::sloop for (ke v)
  305.                  in-table *call-table* count t
  306.                  do (progn ke v nil)))
  307.      (called (make-hash-table :test 'eq :size (+ 3 size))))
  308.     (sloop::sloop for (ke fn) in-table *call-table*
  309.           declare (ignore ke)
  310.           do (sloop::sloop for w in (fn-callees fn)
  311.                    do
  312.                    (setf (gethash w called) t))
  313.           (sloop::sloop for w in (fn-macros fn)
  314.                    do
  315.                    (setf (gethash w called) t))
  316.           
  317.           )
  318.     (sloop::sloop for (ke fn) in-table *call-table*
  319.           when(and
  320.                (not (gethash ke called))
  321.                (member (fn-def fn) '(defun defmacro)
  322.                    :test 'eq))
  323.           collect ke)))
  324.  
  325. ;; redefine the stub in defstruct.lsp
  326. (defun si::record-fn (name def arg-types return-type)
  327.   (if (null return-type) (setq return-type t))
  328.   (and *record-call-info*
  329.        *compiler-in-use*
  330.        (let ((fn (make-fn :name name
  331.               :def def
  332.               :return-type return-type
  333.               :arg-types arg-types)))
  334.      (push fn *all-fns*)
  335.      (setf (gethash name *call-table*) fn))))
  336.  
  337. (defun get-packages (&optional (st "sys-package.lisp") pass
  338.                    &aux (si::*print-package* t))
  339.   (flet ((pr (x) (format st "~%~s" x)))
  340.      (cond ((null pass)
  341.         (with-open-file (st st :direction :output)
  342.           (get-packages st 'establish)
  343.           (get-packages st 'export)
  344.           (get-packages st 'shadow)
  345.           (format st "~2%")
  346.           (return-from get-packages nil))))
  347.     (dolist (p  (list-all-packages))
  348.        (unless
  349.         (member (package-name p)
  350.             '("SLOOP"
  351.               "COMPILER" "SYSTEM" "KEYWORD" "LISP" "USER")
  352.             :test 'equal
  353.             )
  354.         (format st "~2%;;; Definitions for package ~a of type ~a"
  355.             (package-name p) pass)
  356.         (ecase pass
  357.           (establish
  358.            (let ((SYSTEM::*PRINT-PACKAGE* t))
  359.          (pr 
  360.           `(in-package ,(package-name p) :use nil
  361.                    ,@ (if (package-nicknames p)
  362.                       `(:nicknames ',(package-nicknames p)))))))
  363.           (export
  364.            (let ((SYSTEM::*PRINT-PACKAGE* t))
  365.          (pr 
  366.           `(in-package ,(package-name p)
  367.                    :use
  368.                    '(,@
  369.                  (mapcar 'package-name (package-use-list p)))
  370.                    ,@(if (package-nicknames p)
  371.                      `(:nicknames ',(package-nicknames p))))))
  372.            (let (ext (*package* p)
  373.              imps)
  374.          (do-external-symbols (sym p) (push sym ext)
  375.                       (or (eq (symbol-package sym) p)
  376.                       (push sym imps)))
  377.          (pr `(import ',imps))
  378.          (pr `(export ',ext))))
  379.           (shadow
  380.            (let ((SYSTEM::*PRINT-PACKAGE* t))
  381.          (pr `(in-package ,(package-name p))))
  382.            (let (in out (*package* (find-package "LISP")))
  383.          (dolist (v (package-shadowing-symbols p))
  384.              (cond ((eq (symbol-package v) p)
  385.                 (push v in))
  386.                    (t (push v out))))
  387.          (pr `(shadow ',in))
  388.          (pr `(shadowing-import ',out))
  389.          (let (imp)
  390.            (do-symbols (v p)
  391.                    (cond ((not (eq (symbol-package v) p))
  392.                       (push v imp))))
  393.            (pr `(import ',imp))))))))))
  394.